home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / guile / 1.8 / ice-9 / deprecated.scm < prev    next >
Encoding:
Text File  |  2008-12-17  |  6.0 KB  |  181 lines
  1. ;;;; Copyright (C) 2003, 2005, 2006 Free Software Foundation, Inc.
  2. ;;;;
  3. ;;;; This library is free software; you can redistribute it and/or
  4. ;;;; modify it under the terms of the GNU Lesser General Public
  5. ;;;; License as published by the Free Software Foundation; either
  6. ;;;; version 2.1 of the License, or (at your option) any later version.
  7. ;;;; 
  8. ;;;; This library is distributed in the hope that it will be useful,
  9. ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11. ;;;; Lesser General Public License for more details.
  12. ;;;; 
  13. ;;;; You should have received a copy of the GNU Lesser General Public
  14. ;;;; License along with this library; if not, write to the Free Software
  15. ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  16. ;;;;
  17.  
  18. ;;;; Deprecated definitions.
  19.  
  20. (define substring-move-left! substring-move!)
  21. (define substring-move-right! substring-move!)
  22.  
  23. ;; This method of dynamically linking Guile Extensions is deprecated.
  24. ;; Use `load-extension' explicitely from Scheme code instead.
  25.  
  26. (define (split-c-module-name str)
  27.   (let loop ((rev '())
  28.          (start 0)
  29.          (pos 0)
  30.          (end (string-length str)))
  31.     (cond
  32.      ((= pos end)
  33.       (reverse (cons (string->symbol (substring str start pos)) rev)))
  34.      ((eq? (string-ref str pos) #\space)
  35.       (loop (cons (string->symbol (substring str start pos)) rev)
  36.         (+ pos 1)
  37.         (+ pos 1)
  38.         end))
  39.      (else
  40.       (loop rev start (+ pos 1) end)))))
  41.  
  42. (define (convert-c-registered-modules dynobj)
  43.   (let ((res (map (lambda (c)
  44.             (list (split-c-module-name (car c)) (cdr c) dynobj))
  45.           (c-registered-modules))))
  46.     (c-clear-registered-modules)
  47.     res))
  48.  
  49. (define registered-modules '())
  50.  
  51. (define (register-modules dynobj)
  52.   (set! registered-modules
  53.     (append! (convert-c-registered-modules dynobj)
  54.          registered-modules)))
  55.  
  56. (define (warn-autoload-deprecation modname)
  57.   (issue-deprecation-warning
  58.    "Autoloading of compiled code modules is deprecated."
  59.    "Write a Scheme file instead that uses `load-extension'.")
  60.   (issue-deprecation-warning
  61.    (simple-format #f "(You just autoloaded module ~S.)" modname)))
  62.  
  63. (define (init-dynamic-module modname)
  64.   ;; Register any linked modules which have been registered on the C level
  65.   (register-modules #f)
  66.   (or-map (lambda (modinfo)
  67.         (if (equal? (car modinfo) modname)
  68.         (begin
  69.           (warn-autoload-deprecation modname)
  70.           (set! registered-modules (delq! modinfo registered-modules))
  71.           (let ((mod (resolve-module modname #f)))
  72.             (save-module-excursion
  73.              (lambda ()
  74.                (set-current-module mod)
  75.                (set-module-public-interface! mod mod)
  76.                (dynamic-call (cadr modinfo) (caddr modinfo))
  77.                ))
  78.             #t))
  79.         #f))
  80.       registered-modules))
  81.  
  82. (define (dynamic-maybe-call name dynobj)
  83.   (catch #t                ; could use false-if-exception here
  84.      (lambda ()
  85.        (dynamic-call name dynobj))
  86.      (lambda args
  87.        #f)))
  88.  
  89. (define (dynamic-maybe-link filename)
  90.   (catch #t                ; could use false-if-exception here
  91.      (lambda ()
  92.        (dynamic-link filename))
  93.      (lambda args
  94.        #f)))
  95.  
  96. (define (find-and-link-dynamic-module module-name)
  97.   (define (make-init-name mod-name)
  98.     (string-append "scm_init"
  99.            (list->string (map (lambda (c)
  100.                     (if (or (char-alphabetic? c)
  101.                         (char-numeric? c))
  102.                         c
  103.                         #\_))
  104.                       (string->list mod-name)))
  105.            "_module"))
  106.  
  107.   ;; Put the subdirectory for this module in the car of SUBDIR-AND-LIBNAME,
  108.   ;; and the `libname' (the name of the module prepended by `lib') in the cdr
  109.   ;; field.  For example, if MODULE-NAME is the list (inet tcp-ip udp), then
  110.   ;; SUBDIR-AND-LIBNAME will be the pair ("inet/tcp-ip" . "libudp").
  111.   (let ((subdir-and-libname
  112.      (let loop ((dirs "")
  113.             (syms module-name))
  114.        (if (null? (cdr syms))
  115.            (cons dirs (string-append "lib" (symbol->string (car syms))))
  116.            (loop (string-append dirs (symbol->string (car syms)) "/")
  117.              (cdr syms)))))
  118.     (init (make-init-name (apply string-append
  119.                      (map (lambda (s)
  120.                         (string-append "_"
  121.                                (symbol->string s)))
  122.                       module-name)))))
  123.     (let ((subdir (car subdir-and-libname))
  124.       (libname (cdr subdir-and-libname)))
  125.  
  126.       ;; Now look in each dir in %LOAD-PATH for `subdir/libfoo.la'.  If that
  127.       ;; file exists, fetch the dlname from that file and attempt to link
  128.       ;; against it.  If `subdir/libfoo.la' does not exist, or does not seem
  129.       ;; to name any shared library, look for `subdir/libfoo.so' instead and
  130.       ;; link against that.
  131.       (let check-dirs ((dir-list %load-path))
  132.     (if (null? dir-list)
  133.         #f
  134.         (let* ((dir (in-vicinity (car dir-list) subdir))
  135.            (sharlib-full
  136.             (or (try-using-libtool-name dir libname)
  137.             (try-using-sharlib-name dir libname))))
  138.           (if (and sharlib-full (file-exists? sharlib-full))
  139.           (link-dynamic-module sharlib-full init)
  140.           (check-dirs (cdr dir-list)))))))))
  141.  
  142. (define (try-using-libtool-name libdir libname)
  143.   (let ((libtool-filename (in-vicinity libdir
  144.                        (string-append libname ".la"))))
  145.     (and (file-exists? libtool-filename)
  146.      libtool-filename)))
  147.  
  148. (define (try-using-sharlib-name libdir libname)
  149.   (in-vicinity libdir (string-append libname ".so")))
  150.  
  151. (define (link-dynamic-module filename initname)
  152.   ;; Register any linked modules which have been registered on the C level
  153.   (register-modules #f)
  154.   (let ((dynobj (dynamic-link filename)))
  155.     (dynamic-call initname dynobj)
  156.     (register-modules dynobj)))
  157.  
  158. (define (try-module-linked module-name)
  159.   (init-dynamic-module module-name))
  160.  
  161. (define (try-module-dynamic-link module-name)
  162.   (and (find-and-link-dynamic-module module-name)
  163.        (init-dynamic-module module-name)))
  164.  
  165. (define (list* . args)
  166.   (issue-deprecation-warning "'list*' is deprecated.  Use 'cons*' instead.")
  167.   (apply cons* args))
  168.  
  169. ;; The strange prototype system for uniform arrays has been
  170. ;; deprecated.
  171.  
  172. (define uniform-vector-fill! array-fill!)
  173.  
  174. (define make-uniform-vector dimensions->uniform-array)
  175.  
  176. (define (make-uniform-array prot . bounds)
  177.   (dimensions->uniform-array bounds prot))
  178.  
  179. (define (list->uniform-vector prot lst)
  180.   (list->uniform-array 1 prot lst))
  181.